library(ggplot2)
library(gcookbook)
library(corrplot)
## corrplot 0.84 loaded
library(igraph)
## 
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
## 
##     decompose, spectrum
## The following object is masked from 'package:base':
## 
##     union
library(rgl)
## Warning in rgl.init(initValue, onlyNULL): RGL: unable to open X11 display
## Warning: 'rgl_init' failed, running with rgl.useNULL = TRUE
library(grid)
library(vcd)
library(MASS)
library(maps)
library(plyr)
## 
## Attaching package: 'plyr'
## The following object is masked from 'package:maps':
## 
##     ozone
library(maptools)
## Loading required package: sp
## Checking rgeos availability: TRUE

Miscellaneous Graphs

Note: Some problems cannot be completed as written because the code has changed. You will need to find the updated code.

Section 13.1. Making a Correlation Matrix

mcor <- cor(mtcars)
corrplot(mcor)

corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45)

col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))

corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45, col=col(200), addCoef.col="black", addcolorlabel="no", order="AOE")
## Warning in text.default(pos.xlabel[, 1], pos.xlabel[, 2], newcolnames, srt
## = tl.srt, : "addcolorlabel" is not a graphical parameter
## Warning in text.default(pos.ylabel[, 1], pos.ylabel[, 2], newrownames, col
## = tl.col, : "addcolorlabel" is not a graphical parameter
## Warning in title(title, ...): "addcolorlabel" is not a graphical parameter

Section 13.2. Plotting a Function

p <- ggplot(data.frame(x=c(-3,3)), aes(x=x))

p + stat_function(fun = dnorm)

p + stat_function(fun=dt, args=list(df=2))

myfun <- function(xvar) {
    1/(1 + exp(-xvar + 10))
}

ggplot(data.frame(x=c(0, 20)), aes(x=x)) + stat_function(fun=myfun)

limitRange <- function(fun, min, max) {
    function(x) {
        y <- fun(x)
        y[x < min  |  x > max] <- NA
        return(y)
    }
}


p + stat_function(fun = dnorm) +
    stat_function(fun = limitRange(dnorm, 0, 2),
                  geom="area", fill="blue", alpha=0.2)

Section 13.3. Shading a Subregion Under a Function Curve

gd <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6))
plot(gd)

gu <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6), directed=FALSE)

plot(gu, vertex.label=NA)

set.seed(229)
plot(gu)

g <- graph.data.frame(madmen2, directed=TRUE)


par(mar=c(0,0,0,0))

plot(g, layout=layout.fruchterman.reingold, vertex.size=8, edge.arrow.size=0.5,
     vertex.label=NA)

g <- graph.data.frame(madmen, directed=FALSE)
par(mar=c(0,0,0,0))  
plot(g, layout=layout.circle, vertex.size=8, vertex.label=NA)

Section 13.4. Creating a Network Graph

gd <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6))
plot(gd)

gu <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6), directed=FALSE)

plot(gu, vertex.label=NA)

g <- graph.data.frame(madmen2, directed=TRUE)


par(mar=c(0,0,0,0))

plot(g, layout=layout.fruchterman.reingold, vertex.size=8, edge.arrow.size=0.5,
     vertex.label=NA)

 g <- graph.data.frame(madmen, directed=FALSE)
par(mar=c(0,0,0,0))  
plot(g, layout=layout.circle, vertex.size=8, vertex.label=NA)

Section 13.5. Using Text Labels in a Network Graph

m <- madmen[1:nrow(madmen) %% 2 == 1, ]
g <- graph.data.frame(m, directed=FALSE)

V(g)$name
##  [1] "Betty Draper"      "Don Draper"        "Harry Crane"      
##  [4] "Joan Holloway"     "Lane Pryce"        "Peggy Olson"      
##  [7] "Pete Campbell"     "Roger Sterling"    "Sal Romano"       
## [10] "Henry Francis"     "Allison"           "Candace"          
## [13] "Faye Miller"       "Megan Calvet"      "Rachel Menken"    
## [16] "Suzanne Farrell"   "Hildy"             "Franklin"         
## [19] "Rebecca Pryce"     "Abe Drexler"       "Duck Phillips"    
## [22] "Playtex bra model" "Ida Blankenship"   "Mirabelle Ames"   
## [25] "Vicky"             "Kitty Romano"
plot(g, layout=layout.fruchterman.reingold,
     vertex.size        = 4,          
     vertex.label       = V(g)$name,  
     vertex.label.cex   = 0.8,        
     vertex.label.dist  = 0.4,        
     vertex.label.color = "black")

V(g)$size        <- 4
V(g)$label       <- V(g)$name
V(g)$label.cex   <- 0.8
V(g)$label.dist  <- 0.4
V(g)$label.color <- "black"

g$layout <- layout.fruchterman.reingold

plot(g)

E(g)
## + 20/20 edges from 81084af (vertex names):
##  [1] Betty Draper  --Henry Francis     Don Draper    --Allison          
##  [3] Betty Draper  --Don Draper        Don Draper    --Candace          
##  [5] Don Draper    --Faye Miller       Don Draper    --Megan Calvet     
##  [7] Don Draper    --Rachel Menken     Don Draper    --Suzanne Farrell  
##  [9] Harry Crane   --Hildy             Joan Holloway --Franklin         
## [11] Joan Holloway --Roger Sterling    Lane Pryce    --Rebecca Pryce    
## [13] Peggy Olson   --Abe Drexler       Peggy Olson   --Duck Phillips    
## [15] Peggy Olson   --Pete Campbell     Pete Campbell --Playtex bra model
## [17] Roger Sterling--Ida Blankenship   Roger Sterling--Mirabelle Ames   
## [19] Roger Sterling--Vicky             Sal Romano    --Kitty Romano
E(g)[c(2,11,19)]$label <- "M"

E(g)$color             <- "grey70"
E(g)[c(2,11,19)]$color <- "red"

plot(g)

Section 13.6. Creating a Heat Map

pres_rating <- data.frame(
    rating  = as.numeric(presidents),
    year    = as.numeric(floor(time(presidents))),
    quarter = as.numeric(cycle(presidents))
)

pres_rating
##     rating year quarter
## 1       NA 1945       1
## 2       87 1945       2
## 3       82 1945       3
## 4       75 1945       4
## 5       63 1946       1
## 6       50 1946       2
## 7       43 1946       3
## 8       32 1946       4
## 9       35 1947       1
## 10      60 1947       2
## 11      54 1947       3
## 12      55 1947       4
## 13      36 1948       1
## 14      39 1948       2
## 15      NA 1948       3
## 16      NA 1948       4
## 17      69 1949       1
## 18      57 1949       2
## 19      57 1949       3
## 20      51 1949       4
## 21      45 1950       1
## 22      37 1950       2
## 23      46 1950       3
## 24      39 1950       4
## 25      36 1951       1
## 26      24 1951       2
## 27      32 1951       3
## 28      23 1951       4
## 29      25 1952       1
## 30      32 1952       2
## 31      NA 1952       3
## 32      32 1952       4
## 33      59 1953       1
## 34      74 1953       2
## 35      75 1953       3
## 36      60 1953       4
## 37      71 1954       1
## 38      61 1954       2
## 39      71 1954       3
## 40      57 1954       4
## 41      71 1955       1
## 42      68 1955       2
## 43      79 1955       3
## 44      73 1955       4
## 45      76 1956       1
## 46      71 1956       2
## 47      67 1956       3
## 48      75 1956       4
## 49      79 1957       1
## 50      62 1957       2
## 51      63 1957       3
## 52      57 1957       4
## 53      60 1958       1
## 54      49 1958       2
## 55      48 1958       3
## 56      52 1958       4
## 57      57 1959       1
## 58      62 1959       2
## 59      61 1959       3
## 60      66 1959       4
## 61      71 1960       1
## 62      62 1960       2
## 63      61 1960       3
## 64      57 1960       4
## 65      72 1961       1
## 66      83 1961       2
## 67      71 1961       3
## 68      78 1961       4
## 69      79 1962       1
## 70      71 1962       2
## 71      62 1962       3
## 72      74 1962       4
## 73      76 1963       1
## 74      64 1963       2
## 75      62 1963       3
## 76      57 1963       4
## 77      80 1964       1
## 78      73 1964       2
## 79      69 1964       3
## 80      69 1964       4
## 81      71 1965       1
## 82      64 1965       2
## 83      69 1965       3
## 84      62 1965       4
## 85      63 1966       1
## 86      46 1966       2
## 87      56 1966       3
## 88      44 1966       4
## 89      44 1967       1
## 90      52 1967       2
## 91      38 1967       3
## 92      46 1967       4
## 93      36 1968       1
## 94      49 1968       2
## 95      35 1968       3
## 96      44 1968       4
## 97      59 1969       1
## 98      65 1969       2
## 99      65 1969       3
## 100     56 1969       4
## 101     66 1970       1
## 102     53 1970       2
## 103     61 1970       3
## 104     52 1970       4
## 105     51 1971       1
## 106     48 1971       2
## 107     54 1971       3
## 108     49 1971       4
## 109     49 1972       1
## 110     61 1972       2
## 111     NA 1972       3
## 112     NA 1972       4
## 113     68 1973       1
## 114     44 1973       2
## 115     40 1973       3
## 116     27 1973       4
## 117     28 1974       1
## 118     25 1974       2
## 119     24 1974       3
## 120     24 1974       4
p <- ggplot(pres_rating, aes(x=year, y=quarter, fill=rating))

p + geom_tile()

p + geom_raster()

p + geom_tile() +
    scale_x_continuous(breaks = seq(1940, 1976, by = 4)) +
    scale_y_reverse() +
    scale_fill_gradient2(midpoint=50, mid="grey70", limits=c(0,100))

Section 13.7. Creating a Three-Dimensional Scatter Plot

plot3d(mtcars$wt, mtcars$disp, mtcars$mpg, type="s", size=0.75, lit=FALSE)



interleave <- function(v1, v2)  as.vector(rbind(v1,v2))


plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
       xlab="Weight", ylab="Displacement", zlab="MPG",
       size=.75, type="s", lit=FALSE)

segments3d(interleave(mtcars$wt,   mtcars$wt),
           interleave(mtcars$disp, mtcars$disp),
           interleave(mtcars$mpg,  min(mtcars$mpg)),
           alpha=0.4, col="blue")

plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
       xlab = "", ylab = "", zlab = "",
       axes = FALSE,
       size=.75, type="s", lit=FALSE)

segments3d(interleave(mtcars$wt,   mtcars$wt),
           interleave(mtcars$disp, mtcars$disp),
           interleave(mtcars$mpg,  min(mtcars$mpg)),
           alpha = 0.4, col = "blue")

rgl.bbox(color="grey50",          
         emission="grey50",      
         xlen=0, ylen=0, zlen=0) 

rgl.material(color="black")

axes3d(edges=c("x--", "y+-", "z--"),
       ntick=6,                       
       cex=.75)

mtext3d("Weight",       edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG",          edge="z--", line=3)

Section 13.8. Adding a Prediction Surface to a Three-Dimensional Plot

predictgrid <- function(model, xvar, yvar, zvar, res = 16, type = NULL) {

  xrange <- range(model$model[[xvar]])
  yrange <- range(model$model[[yvar]])

  newdata <- expand.grid(x = seq(xrange[1], xrange[2], length.out = res),
                         y = seq(yrange[1], yrange[2], length.out = res))
  names(newdata) <- c(xvar, yvar)
  newdata[[zvar]] <- predict(model, newdata = newdata, type = type)
  newdata
}


df2mat <- function(p, xvar = NULL, yvar = NULL, zvar = NULL) {
  if (is.null(xvar)) xvar <- names(p)[1]
  if (is.null(yvar)) yvar <- names(p)[2]
  if (is.null(zvar)) zvar <- names(p)[3]

  x <- unique(p[[xvar]])
  y <- unique(p[[yvar]])
  z <- matrix(p[[zvar]], nrow = length(y), ncol = length(x))

  m <- list(x, y, z)
  names(m) <- c(xvar, yvar, zvar)
  m
}


interleave <- function(v1, v2)  as.vector(rbind(v1,v2))


m <- mtcars


mod <- lm(mpg ~ wt + disp + wt:disp, data = m)


m$pred_mpg <- predict(mod)


mpgrid_df <- predictgrid(mod, "wt", "disp", "mpg")
mpgrid_list <- df2mat(mpgrid_df)


plot3d(m$wt, m$disp, m$mpg, type="s", size=0.5, lit=FALSE)


spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)


segments3d(interleave(m$wt,   m$wt),
           interleave(m$disp, m$disp),
           interleave(m$mpg,  m$pred_mpg),
           alpha=0.4, col="red")


surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
          alpha=0.4, front="lines", back="lines")
spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)

segments3d(interleave(m$wt,   m$wt),
           interleave(m$disp, m$disp),
           interleave(m$mpg,  m$pred_mpg),
           alpha=0.4, col="red")

surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
          alpha=0.4, front="lines", back="lines")

rgl.bbox(color="grey50",          
         emission="grey50",       
         xlen=0, ylen=0, zlen=0)

rgl.material(color="black")

axes3d(edges=c("x--", "y+-", "z--"),
       ntick=6,                      
       cex=.75)  

mtext3d("Weight",       edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG",          edge="z--", line=3)

Section 13.11. Creating a Dendrogram

c2 <- subset(countries, Year==2009)


c2 <- c2[complete.cases(c2), ]

set.seed(201)
c2 <- c2[sample(1:nrow(c2), 25), ]

c2
##                   Name Code Year        GDP laborrate  healthexp
## 6731          Mongolia  MNG 2009  1690.4170      72.9   74.19826
## 1733            Canada  CAN 2009 39599.0418      67.8 4379.76084
## 4028         Guatemala  GTM 2009  2684.9664      66.9  186.12313
## 611            Austria  AUT 2009 45555.4345      60.4 5037.31089
## 10964           Zambia  ZMB 2009  1006.3882      69.2   47.05637
## 1478          Bulgaria  BGR 2009  6403.1477      54.5  474.84637
## 662         Azerbaijan  AZE 2009  4808.1688      63.0  284.72528
## 3824            Greece  GRC 2009 28936.4809      53.7 3040.73383
## 1070             Benin  BEN 2009   771.7088      72.7   31.92885
## 2957  Egypt, Arab Rep.  EGY 2009  2370.7111      48.8  113.29717
## 4844             Italy  ITA 2009 35073.3225      49.1 3327.62987
## 7037             Nepal  NPL 2009   438.1784      71.5   25.34454
## 6119          Malaysia  MYS 2009  6908.6611      62.0  336.43858
## 4793            Israel  ISR 2009 26102.3506      57.1 1966.47189
## 5252       Korea, Rep.  KOR 2009 17109.9851      60.9 1107.94833
## 5099             Kenya  KEN 2009   744.4031      82.2   33.24912
## 152            Algeria  DZA 2009  4022.1989      58.5  267.94653
## 2447           Croatia  HRV 2009 14322.6081      53.0 1120.37109
## 5609           Lesotho  LSO 2009   800.4202      74.0   70.04993
## 4691           Ireland  IRL 2009 49737.9274      63.6 4951.84469
## 7343           Nigeria  NGA 2009  1091.1344      56.2   69.29737
## 5660           Liberia  LBR 2009   229.2703      71.1   29.35613
## 5558           Lebanon  LBN 2009  8321.3707      46.1  663.27358
## 5966    Macedonia, FYR  MKD 2009  4510.2380      54.0  313.68971
## 10148     Turkmenistan  TKM 2009  3710.4536      68.0   77.06955
##       infmortality
## 6731          27.8
## 1733           5.2
## 4028          25.9
## 611            3.6
## 10964         71.5
## 1478          11.1
## 662           41.1
## 3824           3.5
## 1070          74.7
## 2957          20.0
## 4844           3.2
## 7037          43.3
## 6119           5.6
## 4793           3.7
## 5252           4.3
## 5099          56.3
## 152           32.0
## 2447           4.9
## 5609          67.0
## 4691           3.4
## 7343          90.4
## 5660          77.6
## 5558          19.4
## 5966          10.6
## 10148         48.0
rownames(c2) <- c2$Name
c2 <- c2[,4:7]
c2
##                         GDP laborrate  healthexp infmortality
## Mongolia          1690.4170      72.9   74.19826         27.8
## Canada           39599.0418      67.8 4379.76084          5.2
## Guatemala         2684.9664      66.9  186.12313         25.9
## Austria          45555.4345      60.4 5037.31089          3.6
## Zambia            1006.3882      69.2   47.05637         71.5
## Bulgaria          6403.1477      54.5  474.84637         11.1
## Azerbaijan        4808.1688      63.0  284.72528         41.1
## Greece           28936.4809      53.7 3040.73383          3.5
## Benin              771.7088      72.7   31.92885         74.7
## Egypt, Arab Rep.  2370.7111      48.8  113.29717         20.0
## Italy            35073.3225      49.1 3327.62987          3.2
## Nepal              438.1784      71.5   25.34454         43.3
## Malaysia          6908.6611      62.0  336.43858          5.6
## Israel           26102.3506      57.1 1966.47189          3.7
## Korea, Rep.      17109.9851      60.9 1107.94833          4.3
## Kenya              744.4031      82.2   33.24912         56.3
## Algeria           4022.1989      58.5  267.94653         32.0
## Croatia          14322.6081      53.0 1120.37109          4.9
## Lesotho            800.4202      74.0   70.04993         67.0
## Ireland          49737.9274      63.6 4951.84469          3.4
## Nigeria           1091.1344      56.2   69.29737         90.4
## Liberia            229.2703      71.1   29.35613         77.6
## Lebanon           8321.3707      46.1  663.27358         19.4
## Macedonia, FYR    4510.2380      54.0  313.68971         10.6
## Turkmenistan      3710.4536      68.0   77.06955         48.0
c3 <- scale(c2)

hc <- hclust(dist(c3))

plot(hc)

plot(hc, hang = -1)

Section 13.12. Creating a Vector Field

islice <- subset(isabel, z == min(z))

ggplot(islice, aes(x=x, y=y)) +
       geom_segment(aes(xend = x + vx/50, yend = y + vy/50),
                    size = 0.25) 
## Warning: Removed 3745 rows containing missing values (geom_segment).

islice <- subset(isabel, z == min(z))

every_n <- function(x, by = 2) {
    x <- sort(x)
    x[seq(1, length(x), by = by)]
}

keepx <- every_n(unique(isabel$x), by=4)
keepy <- every_n(unique(isabel$y), by=4)

islicesub <- subset(islice, x %in% keepx  &  y %in% keepy)




ggplot(islicesub, aes(x=x, y=y)) +
    geom_segment(aes(xend = x+vx/50, yend = y+vy/50),
                 arrow = arrow(length = unit(0.1, "cm")), size =0.25)
## Warning: Removed 248 rows containing missing values (geom_segment).

islicesub$speedxy <- sqrt(islicesub$vx^2 + islicesub$vy^2)

ggplot(islicesub, aes(x=x, y=y)) +
    geom_segment(aes(xend = x+vx/50, yend = y+vy/50, alpha = speed),
                 arrow = arrow(length = unit(0.1,"cm")), size = 0.6)
## Warning: Removed 248 rows containing missing values (geom_segment).

usa <- map_data("usa")


ggplot(islicesub, aes(x=x, y=y)) +
    geom_segment(aes(xend = x+vx/50, yend = y+vy/50, colour = speed),
                 arrow = arrow(length = unit(0.1,"cm")), size = 0.6) +
    scale_colour_continuous(low="grey80", high="darkred") +
    geom_path(aes(x=long, y=lat, group=group), data=usa) +
    coord_cartesian(xlim = range(islicesub$x), ylim = range(islicesub$y))
## Warning: Removed 248 rows containing missing values (geom_segment).

keepx <- every_n(unique(isabel$x), by=5)
keepy <- every_n(unique(isabel$y), by=5)
keepz <- every_n(unique(isabel$z), by=2)

isub <- subset(isabel, x %in% keepx  &  y %in% keepy  &  z %in% keepz)

ggplot(isub, aes(x=x, y=y)) +
    geom_segment(aes(xend = x+vx/50, yend = y+vy/50, colour = speed),
                 arrow = arrow(length = unit(0.1,"cm")), size = 0.5) +
    scale_colour_continuous(low="grey80", high="darkred") +
    facet_wrap( ~ z)
## Warning: Removed 151 rows containing missing values (geom_segment).

Section 13.13. Creating a QQ Plot

qqnorm(heightweight$heightIn)
qqline(heightweight$heightIn)
qnorm(heightweight$ageYear)
## Warning in qnorm(heightweight$ageYear): NaNs produced
##   [1] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
##  [18] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
##  [35] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
##  [52] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
##  [69] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
##  [86] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [103] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [120] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [137] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [154] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [171] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [188] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [205] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [222] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
qqline(heightweight$ageYear)

Section 13.14. Creating a Plot of an Empirical Cumulative Distribution Function

ggplot(heightweight, aes(x=heightIn)) + stat_ecdf()

ggplot(heightweight, aes(x=ageYear)) + stat_ecdf()

mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
    highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
    direction=c("v","h","v"))

mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
    highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
    direction=c("v", "v", "h"))

mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
    highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
    direction=c("v", "h", "h"))

Section 13.15. Creating a Mosaic Plot

mosaic( ~ Admit + Gender + Dept, data=UCBAdmissions)

Section 13.16. Creating a Pie Chart

fold <- table(survey$Fold)
fold
## 
##  L on R Neither  R on L 
##      99      18     120
pie(fold)

pie(c(99, 18, 120), labels=c("L on R", "Neither", "R on L"))

Section 13.17. Creating a Map

states_map <- map_data("state")
ggplot(states_map, aes(x=long, y=lat, group=group)) +
    geom_polygon(fill="white", colour="black")

ggplot(states_map, aes(x=long, y=lat, group=group)) +
    geom_path() + coord_map("mercator")

east_asia <- map_data("world", region=c("Japan", "China", "North Korea",
                                        "South Korea"))

ggplot(east_asia, aes(x=long, y=lat, group=group, fill=region)) +
    geom_polygon(colour="black") +
    scale_fill_brewer(palette="Set2")

nz1 <- map_data("world", region="New Zealand")
nz1 <- subset(nz1, long > 0 & lat > -48)        
ggplot(nz1, aes(x=long, y=lat, group=group)) + geom_path()

nz2 <- map_data("nz")
ggplot(nz2, aes(x=long, y=lat, group=group)) + geom_path()

Section 13.18. Creating a Chloropleth Map

crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
crimes
##                         state Murder Assault UrbanPop Rape
## Alabama               alabama   13.2     236       58 21.2
## Alaska                 alaska   10.0     263       48 44.5
## Arizona               arizona    8.1     294       80 31.0
## Arkansas             arkansas    8.8     190       50 19.5
## California         california    9.0     276       91 40.6
## Colorado             colorado    7.9     204       78 38.7
## Connecticut       connecticut    3.3     110       77 11.1
## Delaware             delaware    5.9     238       72 15.8
## Florida               florida   15.4     335       80 31.9
## Georgia               georgia   17.4     211       60 25.8
## Hawaii                 hawaii    5.3      46       83 20.2
## Idaho                   idaho    2.6     120       54 14.2
## Illinois             illinois   10.4     249       83 24.0
## Indiana               indiana    7.2     113       65 21.0
## Iowa                     iowa    2.2      56       57 11.3
## Kansas                 kansas    6.0     115       66 18.0
## Kentucky             kentucky    9.7     109       52 16.3
## Louisiana           louisiana   15.4     249       66 22.2
## Maine                   maine    2.1      83       51  7.8
## Maryland             maryland   11.3     300       67 27.8
## Massachusetts   massachusetts    4.4     149       85 16.3
## Michigan             michigan   12.1     255       74 35.1
## Minnesota           minnesota    2.7      72       66 14.9
## Mississippi       mississippi   16.1     259       44 17.1
## Missouri             missouri    9.0     178       70 28.2
## Montana               montana    6.0     109       53 16.4
## Nebraska             nebraska    4.3     102       62 16.5
## Nevada                 nevada   12.2     252       81 46.0
## New Hampshire   new hampshire    2.1      57       56  9.5
## New Jersey         new jersey    7.4     159       89 18.8
## New Mexico         new mexico   11.4     285       70 32.1
## New York             new york   11.1     254       86 26.1
## North Carolina north carolina   13.0     337       45 16.1
## North Dakota     north dakota    0.8      45       44  7.3
## Ohio                     ohio    7.3     120       75 21.4
## Oklahoma             oklahoma    6.6     151       68 20.0
## Oregon                 oregon    4.9     159       67 29.3
## Pennsylvania     pennsylvania    6.3     106       72 14.9
## Rhode Island     rhode island    3.4     174       87  8.3
## South Carolina south carolina   14.4     279       48 22.5
## South Dakota     south dakota    3.8      86       45 12.8
## Tennessee           tennessee   13.2     188       59 26.9
## Texas                   texas   12.7     201       80 25.5
## Utah                     utah    3.2     120       80 22.9
## Vermont               vermont    2.2      48       32 11.2
## Virginia             virginia    8.5     156       63 20.7
## Washington         washington    4.0     145       73 26.2
## West Virginia   west virginia    5.7      81       39  9.3
## Wisconsin           wisconsin    2.6      53       66 10.8
## Wyoming               wyoming    6.8     161       60 15.6
crime_map <- merge(states_map, crimes, by.x="region", by.y="state")

crime_map <- arrange(crime_map, group, order)
head(crime_map)
##    region      long      lat group order subregion Murder Assault UrbanPop
## 1 alabama -87.46201 30.38968     1     1      <NA>   13.2     236       58
## 2 alabama -87.48493 30.37249     1     2      <NA>   13.2     236       58
## 3 alabama -87.52503 30.37249     1     3      <NA>   13.2     236       58
## 4 alabama -87.53076 30.33239     1     4      <NA>   13.2     236       58
## 5 alabama -87.57087 30.32665     1     5      <NA>   13.2     236       58
## 6 alabama -87.58806 30.32665     1     6      <NA>   13.2     236       58
##   Rape
## 1 21.2
## 2 21.2
## 3 21.2
## 4 21.2
## 5 21.2
## 6 21.2
ggplot(crime_map, aes(x=long, y=lat, group=group, fill=Assault)) +
    geom_polygon(colour="black") +
    coord_map("polyconic")

ggplot(crimes, aes(map_id = state, fill=Assault)) +
    geom_map(map = states_map, colour="black") +
    scale_fill_gradient2(low="#559999", mid="grey90", high="#BB650B",
                         midpoint=median(crimes$Assault)) +
    expand_limits(x = states_map$long, y = states_map$lat) +
    coord_map("polyconic")

qa <- quantile(crimes$Assault, c(0, 0.2, 0.4, 0.6, 0.8, 1.0))
qa
##    0%   20%   40%   60%   80%  100% 
##  45.0  98.8 135.0 188.8 254.2 337.0
crimes$Assault_q <- cut(crimes$Assault, qa,
                      labels=c("0-20%", "20-40%", "40-60%", "60-80%", "80-100%"),
                      include.lowest=TRUE)

pal <- colorRampPalette(c("#559999", "grey80", "#BB650B"))(5)
pal
## [1] "#559999" "#90B2B2" "#CCCCCC" "#C3986B" "#BB650B"
ggplot(crimes, aes(map_id = state, fill=Assault_q)) +
    geom_map(map = states_map, colour="black") +
    scale_fill_manual(values=pal) +
    expand_limits(x = states_map$long, y = states_map$lat) +
    coord_map("polyconic") +
    labs(fill="Assault Rate\nPercentile")

ggplot(crimes, aes(map_id = state, fill=Assault)) +
    geom_map(map = states_map) +
    expand_limits(x = states_map$long, y = states_map$lat) +
    coord_map("polyconic")

Section 13.19. Making a Map with a Clean Background

theme_clean <- function(base_size = 12) {
require(grid) # Needed for unit() function
  theme_grey(base_size) %+replace%
  theme(
    axis.title        = element_blank(),
    axis.text         = element_blank(),
    panel.background  = element_blank(),
    panel.grid        = element_blank(),
    axis.ticks.length = unit(0, "cm"),
    axis.ticks.margin = unit(0, "cm"),
    panel.margin      = unit(0, "lines"),
    plot.margin       = unit(c(0, 0, 0, 0), "lines"),
    complete = TRUE
  )
}

ggplot(crimes, aes(map_id = state, fill=Assault_q)) +
    geom_map(map = states_map, colour="black") +
    scale_fill_manual(values=pal) +
    expand_limits(x = states_map$long, y = states_map$lat) +
    coord_map("polyconic") +
    labs(fill="Assault Rate\nPercentile") +
    theme_clean()
## Warning: `axis.ticks.margin` is deprecated. Please set `margin` property of
## `axis.text` instead
## Warning: `panel.margin` is deprecated. Please use `panel.spacing` property
## instead

Section 13.20. Rceating a Map from a Shapefile


END!